home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / eos / sun-eos-common.el.z / sun-eos-common.el
Encoding:
Text File  |  1998-05-21  |  16.6 KB  |  534 lines
  1. ;; Copyright (C) 1995, Sun Microsystems
  2. ;;
  3. ;; Light Weight Editor Integration for Sparcworks.
  4. ;; "Era on Sparcworks" (EOS)
  5. ;;
  6. ;; Author: Eduardo Pelegri-Llopart
  7. ;;
  8. ;; Please send feedback to eduardo.pelegri-llopart@eng.sun.com
  9.  
  10. ;; Common routines for EOS
  11.  
  12. (defvar eos::version "1.5.2"
  13.   "Version of Eos")
  14.  
  15. (defvar eos::left-margin-width 5
  16.   "size of left margin")
  17.  
  18. (defvar eos::stop-color "red"
  19.   "foreground color for stop signs")
  20. (defvar eos::solid-arrow-color "purple"
  21.   "foreground color for solid arrow")
  22. (defvar eos::hollow-arrow-color "purple"
  23.   "foreground color for hollow arrow")
  24. (defvar eos::sbrowse-arrow-color "blue"
  25.   "foreground color for browser glyphs")
  26.  
  27. (defun eos::recompute-presentation ()
  28.   (set-face-foreground 'stop-face eos::stop-color)
  29.   (set-face-foreground 'solid-arrow-face eos::solid-arrow-color)
  30.   (set-face-foreground 'hollow-arrow-face eos::hollow-arrow-color)
  31.   (set-face-foreground 'sbrowse-arrow-face eos::sbrowse-arrow-color)
  32.   )
  33.  
  34. ;;
  35.  
  36. (defvar eos::displayed-initial-message nil
  37.   "Whether we have shown the initial display message")
  38.  
  39. (defconst eos::startup-message-lines
  40.   '("Please send feedback to eos-comments@cs.uiuc.edu."
  41.     "The latest Eos news are under SPARCworks->News"
  42.     "See Options->SPARCworks for configuration and Help->SPARCworks for help"
  43.     ))
  44.  
  45. ;; copied from vm
  46.  
  47. (defun eos::display-initial-message ()
  48.   ;; Display initial Eos message - REMOVED
  49.   )
  50.  
  51. (defun eos-old::display-initial-message ()
  52.   ;; Display initial Eos message
  53.   (if (not eos::displayed-initial-message)
  54.       (let ((lines eos::startup-message-lines))
  55.     (message "Eos %s, Copyright (C) 1995 Sun MicroSystems"
  56.          eos::version)
  57.     (setq eos::displayed-initial-message t)
  58.     (while (and (sit-for 3) lines)
  59.       (message (car lines))
  60.       (setq lines (cdr lines))))
  61.     (message "")))
  62.  
  63. ;; misc
  64.  
  65. (defun eos::line-at (pos)
  66.   ;; At what line is POS
  67.   (save-restriction
  68.     (widen)
  69.     (save-excursion
  70.       (goto-char pos)
  71.       (beginning-of-line)
  72.       (1+ (count-lines 1 (point))))))
  73.  
  74. ;; frame-specific enabling
  75. ;;
  76. ;; will maintain at most one frame to debugger, one to sbrowser
  77. ;; annotations have a type, either
  78. ;;
  79. ;;    sbrowser
  80. ;;    debugger-solid-arrow
  81. ;;    debugger-holow-arrow
  82. ;;    debugger-stop
  83. ;;    debugger-visit
  84. ;;
  85. ;; adding an annotation of type sbrowser will be only on frame sbrowser
  86. ;; adding an annotation of type debugger will be only on frame debugger
  87. ;;
  88. ;; turn off patterns when there is no frame.
  89.  
  90.  
  91. ;;;
  92. ;;; Common ToolTalk function
  93. ;;;
  94.  
  95. (defun make-an-observer (op callback)
  96.   (let ((pattern-desc
  97.      (list
  98.       'category 'TT_OBSERVE
  99.       'scope 'TT_SESSION
  100.       'class 'TT_NOTICE
  101.       'op op
  102.       'callback callback)))
  103.     (make-tooltalk-pattern pattern-desc)
  104.     ))
  105.  
  106. ;;;
  107. ;;; Frame management
  108. ;;;
  109.  
  110. (defun eos::log (msg)
  111.   (if (fboundp 'ut-log-text)
  112.       (ut-log-text "eos version: %s; %s" eos::version msg)))
  113.  
  114. (defvar eos::sbrowser-frame nil)
  115. (defvar eos::debugger-frame nil)
  116.  
  117. (defun eos::update-specifiers (type old-frame new-frame)
  118.   ;; Change the database for annotations of TYPE, so that OLD-FRAME is
  119.   ;; now using the alternate specifier, while NEW-FRAME uses the main one
  120.   (let* ((device-type (device-type (selected-device)))
  121.      (g (eos::annotation-get-glyph type device-type))
  122.      (im (and (glyphp g) (glyph-image g)))
  123.      (new-instantiator (eos::annotation-get-inst type device-type))
  124.      (alt-instantiator (eos::annotation-get-inst-alt type device-type))
  125.      )
  126.     (if (eq device-type 'x)
  127.     (progn
  128.       (if (frame-live-p old-frame)
  129.           (progn
  130.         (remove-specifier im old-frame)
  131.         (add-spec-to-specifier im alt-instantiator old-frame)))
  132.       (if new-frame
  133.           (progn
  134.         (add-spec-to-specifier im new-instantiator new-frame)
  135.       ))))))
  136.  
  137.  
  138. (defun eos::select-sbrowser-frame (frame)
  139.   (require 'eos-toolbar  "sun-eos-toolbar")
  140.   (let ((toolbar (eos::toolbar-position)))
  141.     (eos::display-initial-message)
  142.     ;; logging
  143.     (if frame
  144.     (eos::log "selected frame for sbrowser")
  145.       (eos::log "unselected frame for sbrowser"))
  146.     ;; TT patterns
  147.     (cond
  148.      ((and (null eos::sbrowser-frame) frame)
  149.       (eos::register-sbrowser-patterns))
  150.      ((and (null frame) eos::sbrowser-frame)
  151.       (eos::unregister-sbrowser-patterns)))
  152.     ;; adjust  toolbars
  153.     (if (frame-live-p eos::sbrowser-frame)
  154.     (remove-specifier toolbar eos::sbrowser-frame))
  155.     (if (frame-live-p eos::debugger-frame)
  156.     (remove-specifier toolbar eos::debugger-frame))
  157.     ;; then add
  158.     (cond
  159.      ((and (frame-live-p eos::debugger-frame) (frame-live-p frame)
  160.        (equal eos::debugger-frame frame))
  161.       (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame))
  162.      ((and (frame-live-p eos::debugger-frame) (frame-live-p frame))
  163.       (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame)
  164.       (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame))
  165.      ((frame-live-p frame)
  166.       (add-spec-to-specifier toolbar eos::sbrowser-toolbar frame))
  167.      ((frame-live-p eos::debugger-frame)
  168.       (add-spec-to-specifier toolbar eos::debugger-toolbar eos::debugger-frame))
  169.      )
  170.     ;; adjust specifiers for glyphs
  171.     (eos::update-specifiers 'sbrowser eos::sbrowser-frame frame)
  172.     (if (frame-live-p eos::sbrowser-frame)
  173.     (progn
  174.       (remove-specifier use-left-overflow eos::sbrowser-frame)
  175.       (remove-specifier left-margin-width eos::sbrowser-frame)))
  176.     (if (frame-live-p frame)
  177.     (progn
  178.       (add-spec-to-specifier use-left-overflow t frame)
  179.       (add-spec-to-specifier left-margin-width eos::left-margin-width frame)
  180.       (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
  181.     (if (frame-live-p eos::debugger-frame)
  182.     (progn
  183.       (add-spec-to-specifier use-left-overflow t eos::debugger-frame)
  184.       (add-spec-to-specifier left-margin-width eos::left-margin-width eos::debugger-frame)
  185.       (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
  186.     ;;
  187.     (setq eos::sbrowser-frame frame)
  188.     (set-menubar-dirty-flag)
  189.     ))
  190.  
  191. (defun eos::select-debugger-frame (frame)
  192.   (require 'eos-toolbar  "sun-eos-toolbar")
  193.   (let ((toolbar (eos::toolbar-position)))
  194.     (eos::display-initial-message)
  195.     (save-excursion
  196.       (eos::ensure-debugger-buffer)
  197.       (bury-buffer))
  198.     ;; logging
  199.     (if frame
  200.     (eos::log "selected frame for debugger")
  201.       (eos::log "unselected frame for debugger"))
  202.     ;; TT patterns
  203.     (cond
  204.      ((and (null eos::debugger-frame) frame)
  205.       (eos::register-debugger-patterns)
  206.       (eos::register-visit-file-pattern))
  207.      ((and (null frame) eos::debugger-frame)
  208.       (eos::unregister-debugger-patterns)
  209.       (eos::unregister-visit-file-pattern)))
  210.     ;; adjust toolbars, remove
  211.     (if (frame-live-p eos::sbrowser-frame)
  212.     (remove-specifier toolbar eos::sbrowser-frame))
  213.     (if (frame-live-p eos::debugger-frame)
  214.     (remove-specifier toolbar eos::debugger-frame))
  215.     ;; then add
  216.     (cond
  217.      ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame)
  218.        (equal eos::sbrowser-frame frame))
  219.       (add-spec-to-specifier toolbar eos::debugger-sbrowser-toolbar frame))
  220.      ((and (frame-live-p eos::sbrowser-frame) (frame-live-p frame))
  221.       (add-spec-to-specifier toolbar eos::debugger-toolbar frame)
  222.       (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame))
  223.      ((frame-live-p frame)
  224.       (add-spec-to-specifier toolbar eos::debugger-toolbar frame))
  225.      ((frame-live-p eos::sbrowser-frame)
  226.       (add-spec-to-specifier toolbar eos::sbrowser-toolbar eos::sbrowser-frame))
  227.      )
  228.     ;; update glyph specifiers
  229.     (eos::update-specifiers 'debugger-solid-arrow eos::debugger-frame frame)
  230.     (eos::update-specifiers 'debugger-hollow-arrow eos::debugger-frame frame)
  231.     (eos::update-specifiers 'debugger-stop eos::debugger-frame frame)
  232.     (if (frame-live-p eos::debugger-frame)
  233.     (progn
  234.       (remove-specifier use-left-overflow eos::debugger-frame)
  235.       (remove-specifier left-margin-width eos::debugger-frame)))
  236.     (if (frame-live-p frame)
  237.     (progn
  238.       (add-spec-to-specifier use-left-overflow t frame)
  239.       (add-spec-to-specifier left-margin-width eos::left-margin-width frame)
  240.       (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
  241.     (if (frame-live-p eos::sbrowser-frame)
  242.     (progn
  243.       (add-spec-to-specifier use-left-overflow t eos::sbrowser-frame)
  244.       (add-spec-to-specifier left-margin-width eos::left-margin-width eos::sbrowser-frame)
  245.       (add-spec-to-specifier left-margin-width 0 (minibuffer-window))))
  246.     ;;
  247.     (setq eos::debugger-frame frame)
  248.     (set-menubar-dirty-flag)
  249.     ))
  250.  
  251. ;; HERE  use file-truename
  252.  
  253. (defun eos::select-frame (type)
  254.   ;; Select a frame; return nil if should skip
  255.   (cond ((eq type 'sbrowser) 
  256.      (if (frame-live-p eos::sbrowser-frame)
  257.          eos::sbrowser-frame
  258.        (message "selecting destroyed frame; will ignore")
  259.        (eos::select-sbrowser-frame nil)
  260.        nil))
  261.     ((or (eq type 'debugger-solid-arrow)
  262.          (eq type 'debugger-hollow-arrow)
  263.          (eq type 'debugger-stop)
  264.          (eq type 'debugger-visit))
  265.      (if (frame-live-p eos::debugger-frame)
  266.          eos::debugger-frame
  267.        (message "selecting destroyed frame; will ignore")
  268.        (eos::select-debugger-frame nil)
  269.        nil))
  270.     (t (selected-frame))))
  271.  
  272. (defun eos::select-window (win)
  273.   ;; Will select a window if it is not showing neither of eos::debugger-buffer or
  274.   ;; eos::toolbar-buffer"
  275.   (let ((name (buffer-name (window-buffer win))))
  276.     (if (and (>= (length name) 4)
  277.          (equal (substring name 0 4) "*Eos"))
  278.     nil
  279.       (select-window win)
  280.       (throw 'found t)
  281.       )))
  282.  
  283. (defun eos::find-line (file line type)
  284.   ;; Show FILE at LINE; returns frame or nil if inappropriate
  285.   ;; if type is nil
  286.   (if (eos::null-file file)
  287.       (selected-frame)
  288.     (let ((sc (eos::select-frame type))
  289.       (win (selected-window)))
  290.       (if (null sc)
  291.       nil
  292.     (select-frame sc)
  293.     (if (catch 'found
  294.           (eos::select-window (selected-window))
  295.           (walk-windows 'eos::select-window)
  296.            nil)
  297.         nil                ; do nothing, already there
  298.       (select-window win)
  299.       (split-window-vertically)
  300.       (other-window 1)
  301.       )
  302.     (switch-to-buffer (find-file-noselect file t)) ;; no warn!
  303.     (if (eq (device-type) 'x) (x-disown-selection))
  304.     (goto-line line)
  305.     sc
  306.     ))))
  307.  
  308. (defun eos::null-file (file)
  309.   ;; returns t if FILE is nil or the empty string
  310.   (or (null file) (equal file "")))
  311.  
  312. ;;;
  313. ;;; Annotation handling
  314. ;;;
  315.  
  316. (defun eos::valid-annotation (annotation)
  317.   ;; returns t if ANNOTATION is an annotation and its buffer exists
  318.   (and (annotationp annotation)
  319.        (bufferp (extent-buffer annotation))
  320.        (buffer-name (extent-buffer annotation)))
  321.   )
  322.  
  323. (defvar eos::annotation-list nil
  324.   "list of annotations set")
  325.  
  326. (defun eos::add-to-annotation-list (ann type)
  327.   (if (not (eq type 'debugger-stop))
  328.       (error "not implemented"))
  329.   (setq eos::annotation-list (cons ann
  330.                       eos::annotation-list))
  331.   )
  332.  
  333. (defun eos::remove-from-annotation-list (ann type)
  334.   (if (not (eq type 'debugger-stop))
  335.       (error "not implemented"))
  336.   (setq eos::annotation-list (delq ann eos::annotation-list))
  337.   )
  338.  
  339. (defun eos::remove-all-from-annotation-list (type)
  340.   (if (not (eq type 'debugger-stop))
  341.       (error "not implemented"))
  342.   (mapcar (function (lambda (annot)
  343.               (if (extent-live-p annot)
  344.               (delete-annotation annot))))
  345.       eos::annotation-list)
  346.   (setq eos::annotation-list nil))
  347.  
  348. (defun eos::add-annotation (type file line uid)
  349.   (let ((anot nil)
  350.     (fr (selected-frame))
  351.     (win (selected-window))
  352.     )
  353.       (if (eos::null-file file)
  354.       (setq anot nil)
  355.     (if (null (eos::find-line file line type))
  356.         (error "No frame to select"))
  357.     (let* ((device-type (device-type (selected-device)))
  358.            (graphics (eos::annotation-get-glyph type device-type))
  359.            (face (eos::annotation-get-face type device-type))
  360.            )
  361.       (setq anot (make-annotation graphics (point) 'outside-margin))
  362.       (set-annotation-data anot uid)
  363.       (set-extent-face anot face)
  364.       (eos::add-to-annotation-list anot type)
  365.       ))
  366.       (select-frame fr)
  367.       (select-window win)
  368.       anot
  369.   ))
  370.  
  371. (defun eos::compare-uid (extent uid)
  372.   (and (annotationp extent)
  373.        (equal (annotation-data extent) uid)
  374.        extent))
  375.  
  376. (defun eos::delete-annotation (type file line uid)
  377.   ;; ignore file and line, they are here for backward compatibility
  378.   (let ((anot nil)
  379.     (alist eos::annotation-list)
  380.     )
  381.     (if (not (eq type 'debugger-stop))
  382.     (error "not implemented"))
  383.     (while (and alist
  384.         (not (equal (annotation-data (car alist)) uid)))
  385.       (setq alist (cdr alist)))
  386.     (if (null alist)
  387.     (error "Event UID not found; ignored")
  388.       (setq anot (car alist))
  389.       (delete-annotation anot)
  390.       (eos::remove-from-annotation-list anot type))
  391.     ))
  392.  
  393. ;; probably type should not be given here... (already stored in the annotation-data
  394. ;; field)  but it is a bit more robust this way.
  395.  
  396. (defun eos::make-annotation-visible (annotation file line type)
  397.   ;; returns nil or moves the ANNOTATION to FILE and LINE; annotation is of TYPE
  398.   (let ((back nil)
  399.     (fr (selected-frame))
  400.     (win (selected-window))
  401.     )
  402.     ;;    (save-window-excursion
  403.     (if (not (eos::null-file file))
  404.     (progn
  405.       (if (eos::valid-annotation annotation)
  406.           (detach-extent annotation) ; should operate on annotations
  407.         )
  408.       (if (null (eos::find-line file line type))
  409.         (error "No frame to select"))
  410.       (let* ((device-type (device-type (selected-device)))
  411.          (graphics (eos::annotation-get-glyph type device-type))
  412.          (face (eos::annotation-get-face type device-type))
  413.          )
  414.         (if (and (eos::valid-annotation annotation)
  415.              (extent-detached-p annotation))
  416.         (progn
  417.           (setq back (insert-extent annotation (point) (point) t))
  418.           (set-annotation-glyph back graphics 'whitespace)
  419.           )
  420.           (setq back (make-annotation graphics (point) 'whitespace))
  421.           )
  422.         (set-annotation-data back type)
  423.         (set-extent-face back face)
  424.         )))
  425.     ;;      )
  426.     (if (not (eq (selected-frame) fr))
  427.     (select-frame fr))
  428.     (select-window win)
  429.     back
  430.     ))
  431.  
  432. (defun eos::make-annotation-invisible (annotation)
  433.   ;; make this ANNOTATION invisible
  434.   (if (eos::valid-annotation annotation)
  435.       (detach-extent annotation)    ;;  should operate on annotations
  436.   ))
  437.  
  438.  
  439. ;; mapping between annotation types and their screen representations.
  440.  
  441. (defvar eos::alist-annotation-glyph nil) ; assoc list of annotation type
  442.                     ;  device type, and glyph
  443. (defvar eos::alist-annotation-inst nil) ; assoc list of annotation type
  444.                     ;  device type, and instantiator
  445. (defvar eos::alist-annotation-inst-alt nil) ; alternate assoc list of annotation type
  446.                     ;  device type, and instantiator
  447.  
  448. (defvar eos::alist-annotation-face nil)  ;;  assoc list of annotation type,
  449.                        ;; device type and face
  450.  
  451. ;; PUBLIC
  452.  
  453. ;; TBD! merge both instance lists.
  454.  
  455. (defun eos::annotation-set-inst (annotation-type device-type inst inst-alt)
  456.   "define the instantiator for ANNOTATION-TYPE on DEVICE-TYPE to be
  457. INST for the frame enabled for this type and INST-ALT for other frames"
  458.   (interactive)
  459.   (setq eos::alist-annotation-inst
  460.     (cons (cons (cons annotation-type device-type) inst)
  461.           eos::alist-annotation-inst))
  462.   (setq eos::alist-annotation-inst-alt
  463.     (cons (cons (cons annotation-type device-type) inst-alt)
  464.           eos::alist-annotation-inst-alt))  )
  465.  
  466. (defun eos::annotation-set-face (annotation-type device-type face-1 face-2)
  467.   "define the face for ANNOTATION-TYPE on DEVICE-TYPE to be
  468. FACE-1 for the frame enabled for this type and FACE-2 for other frames"
  469.   (interactive)
  470.   (setq eos::alist-annotation-face
  471.     (cons (cons (cons annotation-type device-type) face-1)
  472.           eos::alist-annotation-face))
  473.   )
  474.  
  475. ;; PRIVATE
  476.  
  477. (defun eos::annotation-get-glyph (annotation-type device-type)
  478.   ;; Get the glyph for ANNOTATION-TYPE on DEVICE-TYPE
  479.   (interactive)
  480.   (let ((found (assoc (cons annotation-type device-type)
  481.               eos::alist-annotation-glyph)))
  482.     (if found
  483.     (cdr found)
  484.       (let ((inst (eos::annotation-get-inst annotation-type device-type))
  485.         (alt-inst (eos::annotation-get-inst-alt annotation-type device-type))
  486.         (glyph nil)
  487.         (frame (selected-frame)))
  488.     (if (null inst)
  489.         nil
  490.       (setq glyph (make-glyph `((global . (nil . ,alt-inst)))))
  491.       (add-spec-to-specifier (glyph-image glyph) inst frame)
  492.       (setq eos::alist-annotation-glyph
  493.         (cons (cons (cons annotation-type device-type) glyph)
  494.             eos::alist-annotation-glyph))
  495.       glyph))
  496.       )))
  497.  
  498. (defun eos::annotation-get-inst (annotation-type device-type)
  499.   ;; Get the primary instantiator for ANNOTATION-TYPE on DEVICE-TYPE
  500.   (interactive)
  501.   (let ((found (assoc (cons annotation-type device-type)
  502.               eos::alist-annotation-inst)))
  503.     (if found
  504.     (cdr found)
  505.       nil)))
  506.  
  507. (defun eos::annotation-get-inst-alt (annotation-type device-type)
  508.   ;; Get the alternate instantiator for ANNOTATION-TYPE on DEVICE-TYPE
  509.   (interactive)
  510.   (let ((found (assoc (cons annotation-type device-type)
  511.               eos::alist-annotation-inst-alt)))
  512.     (if found
  513.     (cdr found)
  514.       nil)))
  515.  
  516. (defun eos::annotation-get-face (annotation-type device-type)
  517.   ;; Get the face for ANNOTATION-TYPE on DEVICE-TYPE 
  518.   (interactive)
  519.   (let ((found (assoc (cons annotation-type device-type)
  520.               eos::alist-annotation-face))
  521.     )
  522.     (if found
  523.     (cdr found)
  524.       nil
  525.       ))
  526.   )
  527.  
  528.  
  529. (defun eos::common-startup () )
  530. ;;
  531.  
  532.  
  533. (provide 'eos-common)
  534.